Gold Medal Software 1/Gold Medal Software Volume 1 (Gold Medal) (1994).iso/prog/tpwprog5.arj/METRICS.PAS

Pascal/Delphi Source File | 1992-07-02 | 5.2 KB | 238 lines

{ metrics.pas -- Display system metrics (completes WCDEMO.PAS) }

program Metrics;

uses WinCrt, WinTypes, WinProcs, Strings;

const

  maxChoice = 4;    { Number of menu selections }

{- Start a new display line }
procedure NewLine;
begin
  WriteChar(#13);
  WriteChar(#10)
end;

{- PChar equivalent to Write }
procedure Put(P: PChar);
begin
  WriteBuf(P, StrLen(P))
end;

{- PChar equivalent to Writeln }
procedure PutLn(P: PChar);
begin
  Put(P);
  NewLine
end;

{- Display string S centered at line Y }
procedure Center(Y: Integer; S: PChar);
begin
  GotoXY(ScreenSize.X div 2 - StrLen(S) div 2, Y);
  Put(S)
end;

{- Display message, then continue after key press }
procedure Pause;
begin
  NewLine;
  Put('Press any key to continue...');
  repeat { wait } until KeyPressed;
  ReadKey
end;

{- Display menu. Return true and choice in C; else return false }
function GetChoice(var C: Integer): Boolean;
begin
  repeat
    ClrScr;
    Center( 3, 'M E N U');
    Center( 4, '--------------------');
    Center( 6, '1: System metrics   ');
    Center( 8, '2: Keyboard type    ');
    Center(10, '3: Windows directory');
    Center(12, '4: System flags     ');
    Center(15, '9: Exit             ');
    Center(20, 'Enter selection number: ');
    Readln(C)
  until C in [1 .. maxChoice, 9];
  GetChoice := C <> 9
end;

{- Display statistic label }
procedure WriteLabel(S: PChar);
begin
  WriteBuf(S, StrLen(S));
  WriteChar(#32);
  while Cursor.X < 40 do WriteChar('.');
  WriteChar(' ')
end;

{- Display system metrics }
procedure PSystemMetrics;

  procedure ShowInt(S: PChar; Index: Integer);
  begin
    WriteLabel(S);
    Writeln(GetSystemMetrics(Index))
  end;

  procedure ShowBool(S: PChar; Index: Integer);
  begin
    WriteLabel(S);
    if GetSystemMetrics(Index) = 0 then
      Writeln('False')
    else
      Writeln('True')
  end;

begin
  ClrScr;
  Writeln;
  Writeln('System Metrics');
  Writeln('--------------');
  ShowInt('Screen width', sm_CXScreen);
  ShowInt('Screen height', sm_CYScreen);
  ShowInt('Window caption height', sm_CYCaption);
  ShowInt('Icon width', sm_CXIcon);
  ShowInt('Icon height', sm_CYIcon);
  ShowBool('Mouse installed', sm_MousePresent);
  ShowBool('Mouse buttons swapped', sm_SwapButton)
end;

{- Display keyboard type }
procedure PKeyboardType;
const
  keyboard = ' keyboard';  { Common string }
var
  P: PChar;
begin
  ClrScr;
  Writeln;
  Writeln('Keyboard Type');
  Writeln('-------------');
  case GetKeyboardType(0) of
    1: P := 'IBM PC/XT or compatible 83-key';
    2: P := 'Olivetti M24 102-key';
    3: P := 'IBM AT or compatible 84-key';
    4: P := 'IBM Enhanced 101- or 102-key';
    5: P := 'Nokia 1050 or compatible';
    6: P := 'Nokia 9140 or compatible';
  else
    P := 'Unknown';
  end;
  WriteBuf(P, StrLen(P));
  WriteBuf(keyboard, StrLen(keyboard));
end;

{- Display Windows' directory }
procedure PWinDirectory;
const
  errorMsg = '***Error getting directory name';
var
  Buffer: array[0 .. 144] of Char;
  N: Integer;
begin
  ClrScr;
  Writeln;
  Writeln('Windows Directory');
  Writeln('-----------------');
  N := GetWindowsDirectory(Buffer, 144);
  if (N = 0) or (N > 144) then
    WriteBuf(errorMsg, StrLen(errorMsg))
  else
    WriteBuf(Buffer, N)
end;

{- Display system flags }
procedure PSystemFlags;
var
  Flags: LongInt;

  procedure ShowBool(S: PChar; Mask: LongInt);
  begin
    WriteLabel(S);
    if Flags and Mask = 0 then
      Writeln('False')
    else
      Writeln('True')
  end;

  procedure ShowCPU(S: PChar);
  var
    P: PChar;
  begin
    WriteLabel(S);
    if Flags and wf_CPU086 <> 0 then
      P := '8086'
    else if Flags and wf_CPU186 <> 0 then
      P := '80186'
    else if Flags and wf_CPU286 <> 0 then
      P := '80286'
    else if Flags and wf_CPU386 <> 0 then
      P := '80386'
    else if Flags and wf_CPU486 <> 0 then
      P := '80486'
    else
      P := 'Unknown';
    WriteBuf(P, StrLen(P));
    Writeln
  end;

  procedure ShowMode(S: PChar);
  var
    P: PChar;
  begin
    WriteLabel(S);
    if Flags and wf_Enhanced <> 0 then
      P := '386 Enhanced'
    else if Flags and wf_Standard <> 0 then
      P := 'Standard'
    else
      P := 'Real';
    WriteBuf(P, StrLen(P));
    Writeln
  end;

begin
  ClrScr;
  Writeln;
  Writeln('System Metrics');
  Writeln('--------------');
  Flags := GetWinFlags;
  ShowBool('Math coprocessor installed', wf_80x87);
  ShowCPU('Processor (CPU) type');
  ShowMode('Operating mode');
  ShowBool('Protect mode', wf_PMode);
  ShowBool('EMS large-frame configuration', wf_LargeFrame);
  ShowBool('EMS small-frame configuration', wf_SmallFrame)
end;

var

  Choice: Integer;

begin
  while GetChoice(Choice) do
  begin
    case Choice of
      1: PSystemMetrics;
      2: PKeyboardType;
      3: PWinDirectory;
      4: PSystemFlags
    end;
    Writeln;
    Pause
  end;
  DoneWinCrt
end.


{--------------------------------------------------------------
  Copyright (c) 1991 by Tom Swan. All rights reserved.
  Revision 1.00    Date: 4/05/1991
---------------------------------------------------------------}